SuperHack/SuperHack CD.bin/CODING/GRAPHICS/SIRD.ZIP/SIRD.PAS

Pascal/Delphi Source File | 1994-06-20 | 43.9 KB | 1,118 lines

{************************************************}
{                                                }
{   SIRD program                                 }
{                                                }
{   Josef Pöpsel, Dr. Ute Claussen               }
{   for c't, Magazin für Computertechnik         }
{                                                }
{                                                }
{   Please send bug reports to:                  }
{                                                }
{     Josef Pöpsel, Dr. Ute Claussen             }
{     Frohlinder Str. 46                         }
{     44577 Castrop-Rauxel-Schwerin              }
{     Germany                                    }
{     Phone: [phone]                    }
{                                                }
{   Version 1.0                                  }
{   Language: Borland Pascal for Windows V 7.0   }
{                                                }
{   Initial date: Monday, April 27, 1994         }
{   Last changes: Thursday, May 17, 1994         }
{************************************************}

{$A+,B-,D-,F-,G+,I-,K+,L-,N+,P-,Q-,R-,S-,T-,V+,W+,X+,Y-}
{$M 8192,8192}

program SIRD;

{$R SIRD}

uses Win31, WinProcs, WinTypes, OWindows, CommDlg, ODialogs, Strings, BWCC;

procedure AHIncr; far; external 'KERNEL' index 114;   { "Magic Windows Function whose offset
                                                         is used to increment selectors }

const
  HelpFileStr='sird.hlp';   { Filename of HLP-File }

  Max_Sird_Size = 2048;     { Change this and DialogBox in SIRD.RES, if needed }

{ Command IDs }
  cm_LoadDepthPic   = 201;
  cm_LoadTexturePic = 202;
  cm_SaveSIRD       = 203;
  cm_Quit           = 24340;
  cm_SIRDOpts       = 301;
  cm_DoSird         = 401;
  cm_HelpContense   = 501;
  cm_About          = 502;

{ Dialog IDs }

  id_SetEyeDist           = 2001;
  id_SetDPI               = 2002;
  id_UseRandomDots        = 2003;
  id_UseColoredRandomDots = 2004;
  id_UseTexturePicture    = 2005;
  id_SetXRes              = 2006;
  id_SetYRes              = 2007;
  id_SetFixedRatio        = 2008;
  id_AllowMagnification   = 2009;

  OneIO  = 32768;  { No. of bytes handled per huge IO operation }
  BMType = $4D42;  { = 'BM', Signature for Windows BMP-Files    }

  InchPerMeter=100.0/2.54;

type
  PtrRec         = record Lo, Hi: Word end;    { to get from longints to seg:ofs }
  IOFunction     = function(FP: integer; Buf: PChar; Size: Integer): Word;  { function used for hugeIO }

  TMyLOGPALETTE = record case boolean of       { TLOGPALETTE with 256 entries }
                    true: ( palVersion: word;
                            palNumEntries: word;
                            palPalEntry: array[0..255] of TPaletteEntry;);
                    false:( org: TLOGPALETTE);
                  end;

  TMyBITMAPINFO = record case boolean of     { TBITMAPINFO with 256 entries }
                    true: ( bmiHeader: TBitMapInfoHeader;
                            bmiColors: array[0..255] of TRGBQuad;);
                    false: (org: TBITMAPINFO);
                  end;
  { Type of device independant BitMap: }
  DIBType       = record
                    HasPal       : boolean;        { TRUE, if not True Color }
                    XRes,YRes    : longint;        { Resolution of DIB       }
                    BitMapInfo   : TMyBITMAPINFO;  { Windows Header          }
                    LogPalette   : TMyLOGPALETTE;  { The palette, only valid if HasPal }
                    DIBMemHandle : THANDLE;        { Memory Handle of pixel store }
                    PixMem       : pointer;        { Pointer to pixel store }
                    PalHandle    : HPALETTE;       { Windows handle for palette }
                  end;

  { Type of device dependant BitMap, (see DIBType): }
  DDBType       = record
                    HasPal       : boolean;
                    XRes,YRes    : longint;
                    BMPHandle    : HBITMAP;        { Handle of BitMap }
                    PalHandle    : HPALETTE;
                    DC           : HDC;            { Device Context of BitMap }
                    OldObject    : THANDLE;        { Object previously selected in the DC }
                  end;

  { Generic Type for RGB and depth maps }
  MapType    = record
                 XRes,YRes   : longint;
                 BaseAdr     : Pointer;  { South-West corner! }
                 BytesPerLine: longint;
                 MemHandle   : THandle;
               end;

  DepthType  = MapType;  { Type for Depth Pictures }
  RGBMapType = MapType;  { Type for Texture Picture }

  KindType     = (TexW,DepthW,SIRDW,TempW);  { Kind of Window for MDI-Clients }

  { Possible coloring of SIRDs: }
  TexToUseType = (UseRandomDots,UseColoredRandomDots,UseTexturePicture);

  { Type of array to hold constraints: }
  SameArrType  = array[0..Max_Sird_Size-1] of integer;

  { Type of array to hold pixels for one SIRD line: }
  PixArrType   = array[0..Max_Sird_Size-1] of record r,g,b: byte; end;

{ The Dialog: }
  PSIRDOptDialog = ^TSIRDOptDialog;
  TSIRDOptDialog = object(TDialog)
     constructor Init(AParent: PWindowsObject; AName: pchar);
     procedure HelpReq(var Msg: TMessage);  virtual id_First + idHelp;
  end;


{ derived class for MDI clients: }
  PBMPWnd        = ^TBMPWnd;
  TBMPWnd = object(TWindow)
    TheDDB: DDBType;          { The picture of the Client }
    Kind  : KindType;         { What am I? }
    constructor Init(AParent: PWindowsObject;
                     GeneratingDIB: DIBType; TheKind:KindType; title:pchar);
    procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
    procedure GetWindowClass(var WndClass: TWndClass);          virtual;
    procedure WMActivate(var Msg: TMessage);                    virtual wm_First + wm_Activate;
    procedure WMSize(var Msg: TMessage);                        virtual wm_First + wm_Size;
    procedure Redraw(PrecPtr:PRect);
    destructor Done; virtual;
  end;

{ Main window object: }
  PMainWindow = ^TMainWindow;
  TMainWindow = object(TMDIWindow)

    { Variables derived by the dialog box }
    SortOfTexToUse : TexToUseType;   { What kind of SIRD coloring? }
    EyeDist        : single;         { Distance between eyes in DPI }
    DPI            : integer;        { Output resolution in DPI}
    XRes,YRes      : longint;        { Output size in pixel }
    FixedRatio     : boolean;        { XRes/Yres derived by Depth Picture, if TRUE }
    AllowMag       : boolean;        { Texture magnification allowed, if TRUE }


    HasHelp        : boolean;        { TRUE, if user selected HELP }

    { Transfer buffer for Dialog }
    SIRDOpts: record
                 EyeDist        : array[0..15] of char;
                 DPI            : array[0..7] of char;
                 RandomDots,ColoredRandomDots,TexturePicture: word;
                 XRes           : array[0..7] of char;
                 YRes           : array[0..7] of char;
                 FixedRatio     : word;
                 AllowMag       : word;
              end;

    SirdBMPWind,TexBMPWind,DepthBMPWind: PBMPWnd;  { Pointer to possible clients }

    TheRGBMap: RGBMapType;    { The texture used for coloring the SIRD }
    TheDepth: DepthType;      { Depth information used by the SIRD     }
    TheDepthDIB: DIBType;     { Depth picture as DIB, uses same memory as TheDepth! }
    TheSIRD: DIBType;         { The SIRD as True Color DIB }
    SameArr: SameArrType;     { The array to hold contraints }
    PixArr:  PixArrType;      { The array to hold one scan line of the SIRD }

    constructor init(ATitle: PChar; AMenu:HMenu);
    procedure  SetUpWindow; virtual;
    procedure  GetWindowClass(var WndClass: TWndClass); virtual;
    procedure  CMLoadDepth(var Msg: TMessage);          virtual cm_First + cm_LoadDepthPic;
    procedure  CMLoadTex(var Msg: TMessage);            virtual cm_First + cm_LoadTexturePic;
    procedure  CMSaveSIRD(var Msg: TMessage  );         virtual cm_First + cm_SaveSIRD;
    procedure  CMSIRDOpts(var Msg: TMessage);           virtual cm_First + cm_SIRDOpts;
    procedure  CMDoSird(var Msg: TMessage);             virtual cm_First + cm_DoSird;
    procedure  CMHelpContense(var Msg: TMessage);       virtual cm_First + cm_HelpContense;
    procedure  CMAbout(var Msg: TMessage);              virtual cm_First + cm_About;

    procedure  AdjustSIRDRes;             { called, if user selects "fixed ratio" }
    function   ConvertDlgInputs: boolean; { converts the dialog transfer buffer to usable vars }
    procedure  SetPercentage(per:single); { Sets window title to show proceed }
    destructor done; virtual;
  end;

{ Application object }
  TSIRDApp = object(TApplication)
    procedure InitMainWindow; virtual;
  end;

var SIRDApp: TSIRDApp;                     { the application }

{ --------------------------------------- some general functions ------------------------------- }

function pchar2str(p:pchar): string;
{ converts "C" string to Pascal string }
var s:string;
begin
  s[0]:=char(strlen(p));
  move(p^,s[1],ord(s[0]));
  pchar2str:=s;
end;

procedure SetMenuEntry(id:word; mode: word);
{ Sets the menue entry id to the mode mode }
var buf:array[0..100] of char;
    h:hMenu;
begin
  h:=GetMenu(SIRDApp.MainWindow^.HWindow);
  GetMenuString(h,id,@buf,100,mf_bycommand);
  ModifyMenu(h,id,mf_bycommand or mode ,id,@buf);
  DrawMenuBar(SIRDApp.MainWindow^.HWindow);
end;

{ -------------------- some functions to handle big memory arrays: --------------------------- }
procedure __SegIncProc; far; external 'KERNEL' index 114;
var __AddSegInc: LongInt;   (* Additional increment for segments *)

procedure incP1(var p: pointer); (* increments p by 1 *)
var newp: longint;
begin
  longint(p):=longint(p)+1;
  if loWord(longint(p))=0 then p:=pointer(longint(p)+__AddSegInc)
end;

procedure incP(var p: pointer; toAdd: word); (* increments p by toAdd *)
var newp: longint;
begin
  newp:=longint(p)+toAdd;
  if loWord(newp)<loWord(longint(p)) then p:=pointer(newp+__AddSegInc)
  else p:=pointer(newp);
end;

procedure decP(var p: pointer; toSubtract: word); (* decrements p by toAdd *)
var newp: longint;
begin
  newp:=longint(p)-toSubtract;
  if loWord(newp)>loWord(longint(p)) then p:=pointer(newp-__AddSegInc)
  else p:=pointer(newp);
end;

function ADDToBase(p: pointer; l:longint): pointer;
{ Adds l to the pointer p. p must have the offset 0. }
begin
  ADDToBase:=ptr(ptrrec(p).hi+ PtrRec(l).hi*Ofs(AHIncr),ptrrec(l).lo);
end;

{ -------------------------------- some file functions: ------------------------------- }

function GetFileName(mustexist: boolean; FileMask,Description,FileName:pchar): boolean;
{ Gets a filename (FileName) with the Windows 3.1 file dialog box.
  If mustexist=true, the file has to exist beforehand.
  FileMask contains the mask, the file list box uses.
  Description is the text description of the file format, e.g. "Windows BitMap File",
  FileName is the result.
  If FileName is <> NIL, if GetFileName is called, this will be the default FileName. }

var OpenFN      : TOpenFileName;
    Filter      : array [0..100] of Char;
begin
  FillChar(Filter, SizeOf(Filter), #0);  { Set up for single null at the end }
  StrCopy(Filter, description);
  StrCopy(@Filter[StrLen(Filter)+1],FileMask);

  FillChar(OpenFN, SizeOf(TOpenFileName), #0);
  with OpenFN do begin
    hInstance := 0;   hwndOwner   := SIRDApp.MainWindow^.HWindow;   lpstrDefExt    := '';
    lpstrFile := FileName;  lpstrFilter := Filter; lpstrFileTitle := FileName;
    lStructSize   := sizeof(TOpenFileName);
    nFilterIndex  := 1;
    nMaxFile      := SizeOf(FileName);
    flags     := ofn_HideReadOnly;
    if mustexist then begin
      flags:=flags or ofn_FileMustExist;
      GetFileName:=GetOpenFileName(OpenFN);
    end else begin
      flags:=flags or ofn_OverWritePrompt;
      GetFileName:=GetSaveFileName(OpenFN);
    end;
  end;
end;


function HugeIO(IOFunc: IOFunction; F: Integer; P: Pointer; Size: Longint): boolean;
{ Reads/writes size bytes from/to file F; handles to/from P^ depending on IOFunc.
  Size can be > $FFFF. Returns true, if no error. }
var L, N: Longint;
begin
  HugeIO := true;
  L := 0;
  while L < Size do begin
    N := Size - L;
    if N > OneIO then N := OneIO;
    if IOFunc(F,ADDToBase(p,L),Integer(N))<> N then begin
      HugeIO := false;
      Exit; { abnormal termination }
    end;
    Inc(L, N);
  end;
end;

function _LFileSize(F : integer) : longint;
{ Gets the file size of file handled by F. File can be larger than $FFFF. }
var CurPos : longint;
begin
  CurPos := _llseek(F,0,1);
  _LFileSize := _llseek(F,0,2);
  _llseek(F,CurPos,0);
end;



{ ------------------- some functions for the DIBs and DDBs: ------------------------ }

procedure FreeDIB(var TheDIB: DIBType);
{ Frees the contents of a DIBType variable }
begin
  GlobalUnlock(TheDIB.DIBMemHandle);
  GlobalFree(TheDIB.DIBMemHandle);
  if TheDIB.HasPal then DeleteObject(TheDIB.PalHandle);
end;

procedure FreeRGBMap(var TheRGBMap: RGBMapType);
{ Frees the contents of a RGBMapType variable }
begin
  GlobalUnlock(TheRGBMap.MemHandle);
  GlobalFree(TheRGBMap.MemHandle);
end;

function LoadBMPAsDIB(var TheDIB: DIBType): boolean;
{ Loads a Windows BMP-File into a DIB-Structure after querying the file name.
  Returns true, if user didn┤t press cancel.
  TheDIB.XRes is set to -1, if an error occured during loading.}

var fname: pchar;               { Result of file name querying }
    F: Integer;            { File handle for Windows file functions }
    Size: Longint;        { Size of bitmap }
    P: PBitmapInfo;        { Windows bitmap format info header }
    Header: TBitmapFileHeader;  { Bitmap file header }
    i: integer;
    oldCur: HCursor;
begin
  LoadBMPAsDIB:=FALSE;
  TheDIB.XRes:=-1;
  GetMem(fname,255); StrCopy(fname,'*.BMP');
  if GetFileName(TRUE,'*.BMP','Windows BitMap File',fname) then with TheDib do begin
    LoadBMPAsDIB:=TRUE;                               { user didn┤t press cancel }
    OldCur:=SetCursor(LoadCursor(0, idc_Wait));
    F := _LOpen(fname, of_Read);
    if F = -1 then Exit;
    FreeMem(fname,255);
    if (_LRead(F, @Header, SizeOf(Header)) <> SizeOf(Header)) or (Header.bfType <> BMType) then begin
      _LClose(F);  SetCursor(OldCur); Exit;
    end;
    Size := _LFileSize(F) - SizeOf(TBitmapFileHeader);
    DIBMemHandle := GlobalAlloc(gmem_Moveable, Size);
    if DIBMemHandle = 0 then begin _LClose(F); SetCursor(OldCur); Exit; end;
    P := GlobalLock(DIBMemHandle);
    PixMem:=AddToBase(P,Header.bfOffBits - SizeOf(TBitmapFileHeader));
    if HugeIO(_LRead, F, P, Size) and
     (P^.bmiHeader.biSize = SizeOf(TBitmapInfoHeader)) then begin
      Size:=Header.bfOffBits - SizeOf(TBitmapFileHeader);
      if Size>sizeof(TMyBITMAPINFO) then Size:=sizeof(TMyBITMAPINFO);
      move(P^,BitMapInfo,Size);
      XRes:=BitMapInfo.bmiHeader.biWidth;
      YRes:=BitMapInfo.bmiHeader.biHeight;
      if BitMapInfo.bmiHeader.biBitCount<>24 then begin
        HasPal:=TRUE;
        LogPalette.PalVersion:=$300;
        LogPalette.PalNumEntries:=BitMapInfo.bmiHeader.biClrUsed;
        if LogPalette.PalNumEntries=0 then LogPalette.PalNumEntries:=1 shl BitMapInfo.bmiHeader.biBitCount;
        for i:=0 to LogPalette.PalNumEntries-1 do begin
          with BitMapInfo.bmiColors[i], LogPalette.PalPalEntry[i] do begin
            peRed:=rgbRed;
            peGreen:=rgbGreen;
            peBlue:=rgbBlue;
            peFlags:=0;
          end;
        end;
        PalHandle:=CreatePalette(LogPalette.org);
      end else HasPal:=FALSE;
    end else begin
      GlobalUnlock(DIBMemHandle); GlobalFree(DIBMemHandle);
      _LClose(F); SetCursor(OldCur); Exit;
    end;
    _LClose(F);
    SetCursor(OldCur);
  end else FreeMem(fname,255);
end;


function DDBToRGBMap(TheDDB: DDBType; var TheRGBMap: RGBMapType): boolean;
{ Converts a device dependent BitMap to a RGBMapType variable (converts to TrueColor).
  Returns TURE, if successful. }

var BytesNeeded: longint;   { TheRGBMap pixels }
    bmi:TBitMapInfo;        { header of internal TrueColor DIB }
    DC:HDC;                 { device context to build the TrueColor DIB }
    oldCur: HCursor;
begin
  DDBToRGBMap:=FALSE;
  OldCur:=SetCursor(LoadCursor(0, idc_Wait));
  with TheRGBMap do begin
    XRes:=TheDDB.XRes;
    YRes:=TheDDB.YRes;
    BytesPerLine:=(XRes*3+3) and not 3;   (* bytes per line must be a multiple of 4 *)
    BytesNeeded:=BytesPerLine * YRes;
    MemHandle:=GlobalAlloc(gmem_Moveable, BytesNeeded);
    if MemHandle<>0 then BaseAdr := GlobalLock(MemHandle) else exit;
    with bmi.bmiHeader do begin             (* set up the header to get the bits *)
      biSize:=sizeof(TBitMapInfoHeader);
      biWidth:=XRes;          biHeight:=YRes;
      biPlanes:=1;            biBitCount:=24;
      biCompression:=BI_RGB;  biSizeImage:=BytesNeeded;
      biXPelsPerMeter := 0;   biYPelsPerMeter := 0;
      biClrUsed       := 0;   biClrImportant  := 0;
    end;
    DC:=GetDC(0);
    if TheDDB.HasPal then begin            { Select palette, if the DDB has one }
      SelectPalette(DC,TheDDB.PalHandle,false);
      RealizePalette(DC);
    end;
    GetDIBits(DC,TheDDB.BMPHandle,0,YRes,BaseAdr,bmi,DIB_RGB_COLORS);  (* get the bits *)
    ReleaseDC(0,DC);
  end;
  DDBToRGBMap:=TRUE;
  SetCursor(OldCur);
end;

function RGBMapToDepthBuf(TheRGBMap: RGBMapType; var TheDepth: DepthType): boolean;
{ Converts a RGBMapType structure to a DepthType structure by calcualting the
  intensity of every pixel. Returns TRUE, if successful. }
var BytesNeeded: longint;
    oldCur: HCursor;
    ps,pd: pointer;
    x,y,r,g,b: integer;
begin
  RGBMapToDepthBuf:=FALSE;
  OldCur:=SetCursor(LoadCursor(0, idc_Wait));
  with TheDepth do begin
    XRes:=TheRGBMap.XRes;
    YRes:=TheRGBMap.YRes;
    BytesPerLine:=(XRes+3) and not 3;   (* one byte/pixel, bytes per line must be a multiple of 4 *)
    BytesNeeded:=BytesPerLine * YRes;
    MemHandle:=GlobalAlloc(gmem_Moveable, BytesNeeded);
    if MemHandle<>0 then BaseAdr := GlobalLock(MemHandle) else exit;
    for y:=0 to YRes-1 do begin  (* For every scan line: *)
      { Get address of leftmost pixel in source and destination: }
      ps:=AddToBase(TheRGBMap.BaseAdr,y*TheRGBMap.BytesPerLine);
      pd:=AddToBase(TheDepth.BaseAdr,y*TheDepth.BytesPerLine);
      { Convert every pixel of the scan: }
      for x:=0 to XRes-1 do begin
        r:=byte(ps^); incP1(ps);  { Order of color components in DIB-mem is r,g,b }
        g:=byte(ps^); incP1(ps);
        b:=byte(ps^); incP1(ps);
        byte(pd^):=hi(r*130+g*97+b*28);   (* Intensity of color (0.51*r+0.38*g+0.11*b) *)
        incP1(pd);
      end;
    end;
  end;
  RGBMapToDepthBuf:=TRUE;
end;

procedure DepthBufToDIB(TheDepth: DepthType; var TheDIB: DIBType);
{ Converts TheDepth to 8 bit color index DIB with gray scale palette.
  Attention: TheDIB uses the same pixel store as TheDepth does. }
var i: integer;
begin
  with TheDib do begin
    HasPal:=TRUE;
    XRes:=TheDepth.XRes;
    YRes:=TheDepth.YRes;
    PixMem:=TheDepth.BaseAdr;
    DIBMemHandle:=TheDepth.MemHandle;
    with BitMapInfo.bmiHeader do begin   (* Fill up the DIB's header *)
      biSize:=sizeof(TBitMapInfoHeader);
      biWidth:=XRes;          biHeight:=YRes;
      biPlanes:=1;            biBitCount:=8;
      biCompression:=BI_RGB;  biSizeImage:=TheDepth.BytesPerLine*YRes;
      biXPelsPerMeter := 0;   biYPelsPerMeter := 0;
      biClrUsed       := 0;   biClrImportant  := 0;
    end;
    (* Construct grayscale palette for 8 Bit DIBs: *)
    with LogPalette do begin
      PalVersion:=$300; PalNumEntries:=256;
      for i:=0 to 255 do with PalPalEntry[i],BitMapInfo.bmiColors[i] do begin
        peRed:=i; peGreen:=i; peBlue:=i; peFlags:=0;
        rgbBlue:=i; rgbGreen:=i; rgbRed:=i; rgbReserved:=0;
      end;
    end;
    PalHandle:=CreatePalette(LogPalette.org);
  end;
end;

function DIBToDDB(TheDIB: DIBType; var TheDDB: DDBType): boolean;
{ Creates a DC and a DDB (derived from TheDIB) which then is selected for that DC.
  Returnes true, if successful. }
var GotDC: HDC;               { Device context of the screen }
    oldCur: HCursor;
begin
  GotDC:=GetDC(0);
  TheDDB.DC:=CreateCompatibleDC(GotDC);
  OldCur:=SetCursor(LoadCursor(0, idc_Wait));
  if TheDIB.HasPal then begin
    TheDDB.PalHandle:=CreatePalette(TheDIB.LogPalette.org);
    SelectPalette(GotDC,TheDDB.PalHandle,false);
    RealizePalette(GotDC);
  end;
  TheDDB.BMPHandle:= CreateDIBitmap(GotDC,TheDIB.BitMapInfo.bmiHeader,cbm_Init,
                                    TheDIB.PixMem,TheDIB.BitMapInfo.org, dib_RGB_Colors);
  TheDDB.OldObject:=SelectObject(TheDDB.DC,TheDDB.BMPHandle);
  ReleaseDC(0,GotDC);
  TheDDB.HasPal:=TheDib.HasPal;
  TheDDB.XRes:=TheDIB.XRes;
  TheDDB.YRes:=TheDIB.YRes;
  SetCursor(OldCur);
end;

{ ----------------------------------- Methods of TBMPWnd -----------------------------------------}
constructor TBMPWnd.Init(AParent: PWindowsObject; GeneratingDIB: DIBType;
                         TheKind: KindType; title: pchar);
{ Creates a MDI child of kind TheKind which displays the pixels of GeneratingDIB
  as a DDB. The window title is set to title. }
begin
  inherited Init(AParent,title);
  Kind:=TheKind;
  DibToDDB(GeneratingDIB,TheDDB); { Create the DDB }
  attr.w:=TheDDB.XRes+30; attr.h:=TheDDB.YRes+30;
  Attr.Style := Attr.Style or ws_VScroll or ws_HScroll;
  Scroller := New(PScroller, Init(@Self, 1, 1, 200, 200));
  Scroller^.AutoMode:=false;
end;

procedure TBMPWnd.GetWindowClass(var WndClass: TWndClass);
(* Get the Icon we want. *)
begin
  inherited GetWindowClass(WndClass);
  WndClass.hIcon := LoadIcon(HInstance, 'SIRDIcon');
end;

procedure TBMPWnd.WMSize(var Msg: TMessage);
(* Sets scroller and limits the window┤s size to the maximum size of the
   containing BitMap *)
const SIZE_MAXIMIZED=2; (* has been forgotten to be defined in Win..*)
var Rc,Rw:TRect; wc,hc,ww,hw:integer; pnt:TPoint;
begin
  inherited WMSize(Msg);
  GetClientRect(HWindow,Rc);
  GetWindowRect(HWindow,Rw);
  wc:=rc.right-rc.left; hc:=rc.bottom-rc.top;
  ww:=rw.right-rw.left; hw:=rw.bottom-rw.top;
  if wc>TheDDB.XRes then ww:=ww-wc+TheDDB.XRes ;
  if hc>TheDDB.YRes  then hw:=hw-hc+TheDDB.YRes ;
  Scroller^.SetRange(TheDDB.XRes -wc,TheDDB.YRes -hc);
  if Msg.wParam<>SIZE_MAXIMIZED then begin (* if it must be, ok! *)
    GetClientRect(HWindow,Rc);
    GetWindowRect(HWindow,Rw);
    pnt.x:=Rw.left; pnt.y:=Rw.top;
    ScreenToClient(SIRDApp.MainWindow^.HWindow,pnt);
    wc:=rc.right-rc.left; hc:=rc.bottom-rc.top;
    ww:=rw.right-rw.left; hw:=rw.bottom-rw.top;
    if wc>TheDDB.XRes  then ww:=ww-wc+TheDDB.XRes ;
    if hc>TheDDB.YRes  then hw:=hw-hc+TheDDB.YRes ;
    MoveWindow(HWindow,pnt.x,pnt.y,ww,hw,true);
  end;
end;

procedure TBMPWnd.Redraw(PRecPtr:PRect);
{ Redraws an MDI-Child. If PRecPtr=Nil, the window is redrawn completely, otherwise only
  the PRecPtr^portion is redrawn. }
var DC:HDC;
    xs,ys,xd,yd:integer;
begin
  DC:=GetDC(HWindow);
  if PRecPtr<>NIL then with PRecPtr^ do
    BitBlt(DC,left,top,right-left,bottom-top,TheDDB.DC,           (* redraw only a part   *)
              left+Scroller^.XPos,top+Scroller^.YPos,SRCCOPY)
  else                                                        (* redraw it completely *)
    BitBlt(DC,-Scroller^.XPos,-Scroller^.YPos,TheDDB.XRes,TheDDB.YRes,TheDDB.DC,0,0,SRCCOPY);
  ReleaseDC(HWindow,DC);
end;


procedure TBMPWnd.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
(* Redraws the needed part of the actual window *)
begin
  Redraw(@PaintInfo.rcPaint);
end;

procedure TBMPWnd.WMActivate(var Msg: TMessage);
(* If the window's bitmap has a palette, set it! *)
var DC: HDC;
begin
  if TheDDB.HasPal then begin
    DC:=GetDC(HWindow);
    SelectPalette(DC,TheDDB.PalHandle,false);
    RealizePalette(DC);
    ReleaseDC(HWindow,DC);
  end;
  inherited WMActivate(Msg);
end;

destructor TBMPWnd.done;
{ Deletes an MDI client and frees its pixels. The parent┤s pointer to the
  corresponding MID clients are set to NIL. }
begin
  { The next line is a workaround for a bug in the program, or a bug
    in the OWL of Borland. If a MDI client with scrollers is maximized and
    its destructor is called, the program crashes. If anybody knows
    why, please contact us! Address see at the top of this program. }
  if IsZoomed(HWindow) then PMDIWindow(Parent)^.CascadeChildren;
  SelectObject(TheDDB.DC,TheDDB.OldObject);
  DeleteObject(TheDDB.BMPHandle);
  if TheDDB.HasPal then DeleteObject(TheDDB.PalHandle);
  DeleteDC(TheDDB.DC);
  case Kind of
    TexW   : begin
               PMainWindow(Parent)^.TexBMPWind:=NIL;
               FreeRGBMap(PMainWindow(Parent)^.TheRGBMap);
             end;
    DepthW : begin
               PMainWindow(Parent)^.DepthBMPWind:=NIL;
               FreeDIB(PMainWindow(Parent)^.TheDepthDIB);
               SetMenuEntry(cm_DoSird,mf_grayed);
             end;
    SirdW  : begin
               PMainWindow(Parent)^.SIRDBMPWind:=NIL;
               FreeDIB(PMainWindow(Parent)^.TheSIRD);
               SetMenuEntry(cm_SaveSird,mf_grayed);
             end;

  end;
  inherited done;
end;


{ ------------------------ Methods for the dialog boxes ---------------------------------- }
constructor TSIRDOptDialog.Init(AParent: PWindowsObject; AName: pchar);
{ Set up transfer buffers for dialog }
var dummy: pointer;
begin
  inherited Init(AParent,AName);
  dummy:=New(PEdit,InitResource(@Self,id_SetEyeDist,16));
  dummy:=New(PEdit,InitResource(@Self,id_SetDPI,8));
  dummy:=New(PRadioButton,InitResource(@Self,id_UseRandomDots));
  dummy:=New(PRadioButton,InitResource(@Self,id_UseColoredRandomDots));
  dummy:=New(PRadioButton,InitResource(@Self,id_UseTexturePicture));
  dummy:=New(PEdit,InitResource(@Self,id_SetXRes,8));
  dummy:=New(PEdit,InitResource(@Self,id_SetYRes,8));
  dummy:=New(PCheckBox,InitResource(@Self,id_SetFixedRatio));
  dummy:=New(PCheckBox,InitResource(@Self,id_AllowMagnification));
end;

procedure TSIRDOptDialog.HelpReq;
{ Called, if the help button of the dialog is pressed }
begin
  if WinHelp(hWindow,HelpFileStr,HELP_CONTEXT,100) then
    PMainWindow(SIRDApp.MainWindow)^.HasHelp:=TRUE;
end;

{ ----------------------------------- Methods of TMainWindow -----------------------------}
constructor TMainWindow.Init(ATitle: PChar; AMenu: HMenu);
(* Initializes main window, sets size to complete screen *)
var r: TRect;
begin
  inherited init(ATitle,AMenu);
  GetClientRect(GetDesktopWindow,r);
  attr.x:=r.left; attr.y:=r.top; attr.w:=r.right-r.left; attr.h:=r.bottom-r.top;
end;

procedure TMainWindow.SetUpWindow;
(* Set up "global" variables *)
var HDC:THandle;
    dummy:integer;
begin
  inherited SetUpWindow;
  TexBMPWind:=NIL;
  DepthBMPWind:=NIL;
  SIRDBMPWind:=NIL;
  HasHelp:=FALSE;
  with SIRDOpts do begin
    RandomDots:=bf_checked; ColoredRandomDots:=0; TexturePicture:=0;
    wvsprintf(DPI,'72',dummy);
    wvsprintf(EyeDist,'2.5',dummy);
    wvsprintf(XRes,'640',dummy);
    wvsprintf(YRes,'480',dummy);
    FixedRatio:=bf_checked;
    AllowMag:=0;
  end;
  ConvertDlgInputs;  (* Initializes the variables used by the
                        corresponding transfer buffers *)
  HDC:=GetDC(HWindow);
  if GetDeviceCaps(HDC,BITSPIXEL)<15 then
    messagebox(0,'You are running Windows in color index mode so '+
                 'that the display quality of SIRD is not optimal in all cases.'+
                 'Try to run Windows in true color mode (>=32k colors).',
                 'SIRD', MB_TASKMODAL or MB_ICONINFORMATION or MB_OK);
  ReleaseDC(HWindow,HDC);
end;

procedure TMainWindow.GetWindowClass(var WndClass: TWndClass);
{ Display the Icon we want! }
begin
  inherited GetWindowClass(WndClass);
  WndClass.hIcon := LoadIcon(HInstance, 'SIRDIcon');
end;

procedure TMainWindow.AdjustSIRDRes;
{ If fixed ratio is checked, the smaller of XRes and YRes is set to a value
  so that the ratio is identical to that of the depth picture. }
var ratio: single; s: string;
begin
  if (DepthBMPWind<>NIL) and FixedRatio then begin
    ratio:=TheDepth.XRes/TheDepth.YRes;
    if XRes>YRes then YRes:=round(XRes/ratio) else XRes:=round(YRes*ratio);
    str(XRes,s); s:=s+#0; move(s[1],SIRDOpts.XRes,length(s));
    str(YRes,s); s:=s+#0; move(s[1],SIRDOpts.YRes,length(s));
  end;
end;


procedure TMainWindow.CMLoadDepth(var Msg: TMessage);
{ Loads a depth image and diplays it }
var TheDIB: DIBType;
    DepthColBMPWind:PBMPWnd;
    MyRGBMap: RGBMapType;
begin
  if LoadBMPAsDIB(TheDIB) then begin
    if not TheDib.XRes=-1 then messagebox(HWindow,'Error loading BitMap',
                                          'SIRD', MB_TASKMODAL or MB_ICONEXCLAMATION or MB_OK)
    else begin
      if DepthBMPWind<>NIL then DepthBMPWind^.Done; { Delete the old, if it exists }
      { Display the loaded picture: }
      DepthColBMPWind:=PBMPWnd(SirdApp.MakeWindow(New(PBMPWnd,Init(@Self,TheDib,TempW,'Color-Depth'))));
      DepthColBMPWind^.Redraw(NIL);                     { We want to see it now!        }
      FreeDib(TheDib);                                  { Not needed any longer         }
      DDBToRGBMap(DepthColBMPWind^.TheDDB,MyRGBMap);    { Convert the DDB to a RGB-Map  }
      RGBMapToDepthBuf(MyRGBMap,TheDepth);              { Convert RGB-Map to Depth-Map  }
      FreeRGBMap(MyRGBMap);                             { Not needed any longer         }
      DepthBufToDIB(TheDepth,TheDepthDIB);              { Convert Depth to DIB          }
      DepthColBMPWind^.Done;                            { We don┤t want it any more     }
      { Display the depth picture (a gray level version of the loaded picture): }
      DepthBMPWind:=PBMPWnd(SirdApp.MakeWindow(New(PBMPWnd,Init(@Self,TheDepthDib,DepthW,'Depth'))));
      XRes:=TheDepth.Xres; YRes:=TheDepth.Yres;
      AdjustSIRDRes;                       { Now we have a ratio which can be adjusted  }
      SetMenuEntry(cm_DoSird,0);           { Depth is loaded, so we can calculate SIRDS }
    end;
  end;
end;

procedure TMainWindow.CMLoadTex(var Msg: TMessage);
{ Loads a texture and displays it in an MDI window }
var TheDIB: DIBType;  { Temp. store for the texture }
begin
  if LoadBMPAsDIB(TheDIB) then begin  { Load one }
    if not TheDib.XRes=-1 then  messagebox(HWindow,'Error loading BitMap',
                                          'SIRD', MB_TASKMODAL or MB_ICONEXCLAMATION or MB_OK)
    else begin
      if TexBMPWind<>NIL then TexBMPWind^.Done; { If old exists, free it }
      { Make a new MDI window: }
      TexBMPWind:=PBMPWnd(SirdApp.MakeWindow(New(PBMPWnd,Init(@Self,TheDib,TexW,'Texture'))));
      { Convert its DDB to a RGB-Map: }
      DDBToRGBMap(TexBMPWind^.TheDDB,TheRGBMap);
      FreeDib(TheDib);  { We don┤t need the DIB any more, because we use TheRGBMap }
    end;
  end;
end;

procedure TMainWindow.CMAbout(var Msg: TMessage);
{ Advertising is a MUST ... }
begin
  Application^.ExecDialog(New(PDialog, Init(@Self, 'AboutDialog')));
end;

procedure TMainWindow.CMHelpContense(var Msg: TMessage);
{ Help is wanted }
begin
  if WinHelp(hWindow,HelpFileStr,HELP_CONTENTS,0)then
    PMainWindow(SIRDApp.MainWindow)^.HasHelp:=TRUE;
end;

procedure TMainWindow.CMSIRDOpts(var Msg: TMessage);
{ Displays the dialog box as long as no input error occurs.
  Converts the transfer buffer to usable variables by calling ConvertDlgInputs }
var TheDialog: PSIRDOptDialog;
begin
  repeat
    TheDialog:=New(PSirdOptDialog, Init(@Self, 'SIRDOptionDialog'));
    TheDialog^.TransferBuffer:=@SirdOpts;
    Application^.ExecDialog(TheDialog);
  until ConvertDlgInputs;
end;


function TMainWindow.ConvertDlgInputs: boolean;
(* Converts the dialog transfer buffer to "normal" variables *)
var s:string;
    err:integer;
    f:file;
begin
  if SIRDOpts.RandomDots=bf_checked then SortOfTexToUse:=UseRandomDots
  else if SIRDOpts.ColoredRandomDots=bf_checked  then SortOfTexToUse:=UseColoredRandomDots
  else if SIRDOpts.TexturePicture=bf_checked  then SortOfTexToUse:=UseTexturePicture;
  val(pchar2str(SIRDOpts.DPI),DPI,err);
  if err=0 then val(pchar2str(SIRDOpts.EyeDist),EyeDist,err);
  if err=0 then val(pchar2str(SIRDOpts.XRes),XRes,err);
  if err=0 then val(pchar2str(SIRDOpts.YRes),YRes,err);

  if DPI<20 then err:=1; if DPI>3000 then err:=1;
  if EyeDist<1.0 then err:=1; if EyeDist>5.0 then err:=1;
  if XRes<100 then err:=1; if XRes>Max_Sird_Size then err:=1;
  if YRes<100 then err:=1; if YRes>Max_Sird_Size then err:=1;
  FixedRatio:=SIRDOpts.FixedRatio=bf_checked;
  AllowMag:=SIRDOpts.AllowMag=bf_checked;
  AdjustSIRDRes;
  ConvertDlgInputs:=err=0;
end;

procedure TMainWindow.SetPercentage(per:single);
(* Sets the window title to "SIRD  per%". IF per is less than 0,
   the window title is set to "SIRD". *)
var buf:string;
    peri:integer;
const oldper:integer=-1;
begin
  peri:=round(per);
  if peri<>oldper then begin
    if peri<0 then buf:='SIRD'+#0
    else begin
      str(peri:3,buf);
      buf:='SIRD ('+buf+'%)'+#0;
    end;
    SetWindowText(HWindow,@Buf[1]);
    oldper:=peri;
  end;
end;


procedure MakeSameArr(pDepth: pointer; xDepthStep: single; Cnt: integer;
                      EyeDist: single; Resolution: integer;
                      var SameArr: SameArrType);
{
  Calculation of constraints for one scan line in the SIRD output.

  pDepth     points to the memory with the depth information for this
             line (one byte per pixel, 0 is far away, 255 is nearby)

  xDepthStep is the step size to do in the depth buffer for one step
             in the SIRD line. This variable is needed, because the
             depth picture resolution and the SIRD-Resolution don┤t
             have to be the same.

  Cnt        is the number of Pixels in one SIRD output line.

  EyeDist    is the distance of the eyes in Inch.

  Resolution is the output resolution of the SIRD in DPI.

  SameArr    holds the Result of the procedure. It┤s funct6ionality
             is explained in the text.
}

const zScal=1.0/255.0;    { Depth scaling factor                       }
      mu   =1.0/3.0;      { Distance of the near plane to the far      }

var   x         : integer;{ Position in the SIRD line                  }
      xdo,xd    : integer;{ old, actual position in the depth buffer   }
      depx      : single; { real actual position in depth buffer       }
      p,ph      : pointer;{ pointers into depth buffer                 }
      Z         : single; { normalized depth buffer value at x         }
      Zorg      : integer;{ unnormalized depth buffer value at x       }
      E         : single; { Eyes distance [in pixels of the SIRD]      }
      left,right: integer;{ separated projections of the actual pixels }
      s         : integer;{ separation [in pixels of the SIRD]         }
      visible   : boolean;{ true, if both eyes can see the point       }
      t,ts,zt   : integer;{ used for hidden surface removal            }
      ft        : single; { used for hidden surface removal            }
      l         : integer;{ value of SameArr[left], see text           }

begin
  for x:=0 to Cnt-1 do SameArr[x]:=x; { All values are "unconstrained" }
  E:=round(EyeDist*Resolution);       { EyeDist [in pixels of the SIRD]}
  ft:=2/(zScal*mu*E);                 { Factor for hidden surface      }
  depx:=0; xdo:=0; xd:=0; p:=pDepth;  { Set up step variables and ptr. }
  for x:=0 to Cnt-1 do begin          { for all x of the SIRD line:    }
    Zorg:=byte(p^);                   { Get the depth                  }
    Z:=zorg * zScal;                  { Scale it to 0.0..1.0           }
    s:=round((1.0-mu*Z)*E/(2.0-mu*Z));      { Calculate separation     }
    left:=x-s div 2; right:=left+s;         { this would be seen       }
    if (0<=left) and (right<Cnt) then begin { if both are in the SIRD: }
      t:=1;               { test x+-t, whether it hides x, start at t=1}
      repeat
        zt:=Zorg+round((2-mu*z)*t*ft); { the biggest z allowed (0..255)}
        ts:=round(t*xDepthStep);       { transform t into  depth buffer}
        ph:=p; decP(ph,ts);            { get depth pixel at x-t        }
        visible:=byte(ph^)<zt;         { is it hiding the pixel at x?  }
        if visible then begin          { no? May be the one at x+t does}
          ph:=p; incP(ph,ts);          { get depth pixel at x+t        }
          visible:=byte(ph^)<zt;       { is it hiding the pixel at x?  }
        end;
        inc(t);                          { For the next time           }
      until (not visible) or (zt>255); { until hidden or in front of }
      if visible then begin              { if seen from both eyes:     }
        l:=SameArr[left];                         { set up l, see text }
        while (l<>left) and (l<>right) do begin   { ---- see text ---- }
          if (l<right) then begin                 { ---- see text ---- }
            left:=l; l:=SameArr[left];            { ---- see text ---- }
          end else begin                          { ---- see text ---- }
            SameArr[left]:=right; left:=right;    { ---- see text ---- }
            l:=SameArr[left]; right:=l;           { ---- see text ---- }
          end;                                    { ---- see text ---- }
        end;                                      { ---- see text ---- }
        SameArr[left]:=right;                     { Set the constraint }
      end;
    end;
    depx:=depx+xDepthStep;       { Do a real step for the depth buffer }
    xd:=round(depx);             { This is the integer coordinate of it}
    incP(p,xd-xdo);              { Get the next depth address          }
    xdo:=xd;                     { For the next address-increment      }
  end;
end;


procedure TMainWindow.CMDoSIRD(var Msg: TMessage);
{ Calculate the complete SIRD }
var BytesNeeded,BytesPerLine: longint;
    oldCur: HCursor;
    ThisSortOfTex: TexToUseType;
    y:integer;
    pSird,pS,pDepth,pDeptho,pTex: pointer;
    DepthXStep,DepthYStep: single;
    x: integer;
    MaxSep: integer;
    xtex,ytex:integer;
    texstep:single;
begin
  if SIRDBMPWind<>NIL then SIRDBMPWind^.Done;
  if TexBMPWind<>Nil then TexBMPWind^.Redraw(Nil);
  if DepthBMPWind<>Nil then DepthBMPWind^.Redraw(Nil);
  ThisSortOfTex:=SortOfTexToUse;
  if (ThisSortOfTex=UseTexturePicture) and (TexBMPWind=Nil) then begin
    messagebox(HWindow,'Texture enabled but not loaded, choose one!',
                       'SIRD', MB_TASKMODAL or MB_ICONEXCLAMATION or MB_OK);
    ThisSortOfTex:=UseRandomDots;
  end;
  OldCur:=SetCursor(LoadCursor(0, idc_Wait));
  (* Generate DIB for the SIRD: *)
  BytesPerLine:=(XRes*3+3) and not 3;
  BytesNeeded:=BytesPerLine * YRes;
  TheSIRD.XRes:=XRes;
  TheSIRD.YRes:=YRes;
  with TheSIRD do begin
    HasPal:=FALSE;
    DIBMemHandle:=GlobalAlloc(gmem_Moveable, BytesNeeded);
    if DIBMemHandle<>0 then PixMem := GlobalLock(DIBMemHandle) else exit;
    with BitMapInfo.bmiHeader do begin
      biSize:=sizeof(TBitMapInfoHeader);
      biWidth:=XRes;          biHeight:=YRes;
      biPlanes:=1;            biBitCount:=24;
      biCompression:=BI_RGB;  biSizeImage:=BytesNeeded;
      biXPelsPerMeter := round(DPI*InchPerMeter);
      biYPelsPerMeter := biXPelsPerMeter;
      biClrUsed       := 0;   biClrImportant  := 0;
    end;
  end;
  (* Set up pointers for depth buffer and SIRD image *)
  pSird:=TheSIRD.PixMem;
  pDepth:=TheDepth.BaseAdr;
  pDeptho:=NIL;
  DepthXStep:=(TheDepth.XRes-1)/(XRes-1); (* Steps for depth buffer   *)
  DepthYStep:=(TheDepth.YRes-1)/(YRes-1);
  MaxSep:=round(EyeDist*DPI*0.5);      (* Separation for far plane    *)
  for y:=0 to YRes-1 do begin          (* for all scans in SIRD:      *)
    SetPercentage(y/yRes*100);         (* show process                *)
    if pDepth<>pDeptho then            (* did we step in y for depth? *)
      (* Calculate the constraints: *)
      MakeSameArr(pDepth,DepthXStep,XRes,EyeDist,DPI,SameArr);
    pDeptho:=pDepth;                             (* for the next scan *)
    if ThisSortOfTex=UseRandomDots then begin    (* black & white RDs *)
      for x:=XRes-1 downto 0 do begin
        if SameArr[x]=x then with PixArr[x] do begin  (* free choice? *)
          r:=lo(255+random(2)); g:=r; b:=r;
        end else PixArr[x]:=PixArr[SameArr[x]];
      end;
    end else if ThisSortOfTex=UseColoredRandomDots then begin
      for x:=XRes-1 downto 0 do begin
        if SameArr[x]=x then with PixArr[x] do begin
          r:=random(255);
          g:=random(255);
          b:=random(255);
        end else PixArr[x]:=PixArr[SameArr[x]];
      end;
    end else begin
      texstep:=TheRGBMap.XRes/MaxSep;             (* step in texture  *)
      if not AllowMag then if texstep<1.0 then texstep:=1.0;

      ytex:=round(y*texstep) mod TheRGBMap.YRes;        (* y in texture *)
      for x:=XRes-1 downto 0 do begin
        if SameArr[x]=x then with PixArr[x] do begin    (* free choice? *)
          xtex:=round(x*texstep) mod TheRGBMap.XRes;    (* x in texture *)
          pTex:=AddToBase(TheRGBMap.BaseAdr,TheRGBMap.BytesPerLine*yTex+xTex*3);
          (* Copy the pixel: *)
          b:=byte(pTex^); incP1(pTex);
          g:=byte(pTex^); incP1(pTex);
          r:=byte(pTex^);
        end else PixArr[x]:=PixArr[SameArr[x]];        (* constrained *)
      end;
    end;

    (* copy Pixels of PixArr to SIRD-DIB: *)
    pS:=pSird;
    for x:=0 to XRes-1 do with PixArr[x] do begin
      byte(ps^):=b; incP1(ps);
      byte(ps^):=g; incP1(ps);
      byte(ps^):=r; incP1(ps);
    end;
    (* Increment pointers to SIRD and depth buffer: *)
    incP(pSird,BytesPerLine);
    pDepth:=AddToBase(TheDepth.BaseAdr,round(y*DepthYStep)*TheDepth.BytesPerLine);
  end;

  SetPercentage(-1);
  (* Show the DIB: *)
  SIRDBMPWind:=PBMPWnd(SirdApp.MakeWindow(New(PBMPWnd,Init(@Self,TheSIRD,SirdW,'SIRD-Output'))));
  (* Enable saving: *)
  SetMenuEntry(cm_SaveSird,0);
  SetCursor(OldCur);
end;

procedure TMainWindow.CMSaveSIRD(var Msg: TMessage);
(* Saves the Pixels of the SIRD in a 24 bit BMP-File *)
var fname: pchar;
    F: Integer;            { File Handle for Windows file functions }
    Header: TBitmapFileHeader;  { Bitmap file header }
    oldCur: HCursor;
    BytesNeeded: longint;
    OfStruct:TOfStruct;

label Error;

begin
  GetMem(fname,255); StrCopy(fname,'*.BMP');
  if GetFileName(FALSE,'*.BMP','Windows BitMap File',fname) then with TheSIRD do begin
    OldCur:=SetCursor(LoadCursor(0, idc_Wait));
    F := OpenFile(fname, OfStruct, of_create);
    if F = -1 then goto Error;
    BytesNeeded := ((XRes*3+3) and not 3) * YRes;
    with Header do begin
      bfType:=BMType;
      bfOffBits:=SizeOf(Header)+SizeOf(TheSIRD.BitMapInfo.org);
      bfSize:=bfOffBits+BytesNeeded;
      bfReserved1:=0;
      bfReserved2:=0;
    end;
    if _LWrite(F, @Header, SizeOf(Header)) <> SizeOf(Header) then begin
      _LClose(F); goto Error;
    end;
    if _LWrite(F, @TheSIRD.BitMapInfo.org, SizeOf(TheSIRD.BitMapInfo.org)) <>
                                           SizeOf(TheSIRD.BitMapInfo.org) then begin
      _LClose(F); goto Error;
    end;

    if not HugeIO(_LWrite, F, PixMem, BytesNeeded) then begin
      _LClose(F); goto Error;
    end;

    _LClose(F);
    SetCursor(OldCur);
  end;
  FreeMem(fname,255);
  exit;
Error:
  FreeMem(fname,255);
  SetCursor(OldCur);
  messagebox(HWindow,'Error saving BitMap','SIRD', MB_TASKMODAL or MB_ICONEXCLAMATION or MB_OK)
end;


destructor TMainWindow.done;
(* Close the Help-Window, if opened: *)
begin
  if HasHelp then WinHelp(hWindow,HelpFileStr,HELP_QUIT,0);
  inherited done;
end;

{ ----------------------------------- Methods of TSIRDApp -----------------------------------------}

procedure TSIRDApp.InitMainWindow;
{ Create the application's main window. }
begin
  MainWindow := New(PMainWindow, Init('SIRD',LoadMenu(HInstance, 'MainMenu')));
end;


begin
  __AddSegInc:=ofs(__SegIncProc);
  __AddSegInc:=(__AddSegInc-1) shl 16; (* Correction of segments, if offset overflow *)
  SIRDApp.Init('SIRD');
  SIRDApp.Run;
  SIRDApp.Done;
end.